home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlbfun.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  19.0 KB  |  859 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlbfun.c
  5. * RCS:          $Header: xlbfun.c,v 1.4 91/03/24 22:24:21 mayer Exp $
  6. * Description:  xlisp basic built-in functions
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 03:37:11 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlbfun.c,v 1.4 91/03/24 22:24:21 mayer Exp $";
  43.  
  44. #include "xlisp.h"
  45.  
  46. /* external variables */
  47. extern LVAL xlenv,xlfenv,xldenv,true;
  48. extern LVAL s_evalhook,s_applyhook;
  49. /* extern LVAL s_car,s_cdr,s_nth,s_get,s_svalue,s_splist,s_aref; */ /* NPM: commented this out since it is not used in this file */
  50. /* extern LVAL s_lambda,s_macro; */ /* NPM: commented this out since it is not used in this file */
  51. /* extern LVAL s_comma,s_comat; */ /* NPM: commented this out since it is not used in this file */
  52. extern LVAL s_unbound;
  53. extern char gsprefix[];
  54. extern int gsnumber;
  55.  
  56. /* external routines */
  57. extern LVAL xlxeval();
  58.  
  59. /* forward declarations */
  60. /* FORWARD LVAL bquote1(); */    /* NPM: commented this out since it is not used in this file (declared LOCAL in xlcont.c) */
  61. /* FORWARD LVAL defun(); */      /* NPM: commented this out since it is not defined anywhere */
  62. LOCAL FORWARD LVAL makesymbol(); /* NPM: changed this to LOCAL */
  63.  
  64. /* xeval - the built-in function 'eval' */
  65. LVAL xeval()
  66. {
  67.     LVAL expr;
  68.  
  69.     /* get the expression to evaluate */
  70.     expr = xlgetarg();
  71.     xllastarg();
  72.  
  73.     /* evaluate the expression */
  74.     return (xleval(expr));
  75. }
  76.  
  77. /* xapply - the built-in function 'apply' */
  78. LVAL xapply()
  79. {
  80.     LVAL fun,arglist;
  81.  
  82.     /* get the function and argument list */
  83.     fun = xlgetarg();
  84.     arglist = xlgalist();
  85.     xllastarg();
  86.  
  87.     /* apply the function to the arguments */
  88.     return (xlapply(pushargs(fun,arglist)));
  89. }
  90.  
  91. /* xfuncall - the built-in function 'funcall' */
  92. LVAL xfuncall()
  93. {
  94.     LVAL *newfp;
  95.     int argc;
  96.     
  97.     /* build a new argument stack frame */
  98.     newfp = xlsp;
  99.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  100.     pusharg(xlgetarg());
  101.     pusharg(NIL); /* will be argc */
  102.  
  103.     /* push each argument */
  104.     for (argc = 0; moreargs(); ++argc)
  105.     pusharg(nextarg());
  106.  
  107.     /* establish the new stack frame */
  108.     newfp[2] = cvfixnum((FIXTYPE)argc);
  109.     xlfp = newfp;
  110.  
  111.     /* apply the function to the arguments */
  112.     return (xlapply(argc));
  113. }
  114.  
  115. /* xmacroexpand - expand a macro call repeatedly */
  116. LVAL xmacroexpand()
  117. {
  118.     LVAL form;
  119.     form = xlgetarg();
  120.     xllastarg();
  121.     return (xlexpandmacros(form));
  122. }
  123.  
  124. /* x1macroexpand - expand a macro call */
  125. LVAL x1macroexpand()
  126. {
  127.     LVAL form,fun,args;
  128.  
  129.     /* protect some pointers */
  130.     xlstkcheck(2);
  131.     xlsave(fun);
  132.     xlsave(args);
  133.  
  134.     /* get the form */
  135.     form = xlgetarg();
  136.     xllastarg();
  137.  
  138.     /* expand until the form isn't a macro call */
  139.     if (consp(form)) {
  140.     fun = car(form);        /* get the macro name */
  141.     args = cdr(form);        /* get the arguments */
  142.     if (symbolp(fun) && fboundp(fun)) {
  143.         fun = xlgetfunction(fun);    /* get the expansion function */
  144.         macroexpand(fun,args,&form);
  145.     }
  146.     }
  147.  
  148.     /* restore the stack and return the expansion */
  149.     xlpopn(2);
  150.     return (form);
  151. }
  152.  
  153. /* xatom - is this an atom? */
  154. LVAL xatom()
  155. {
  156.     LVAL arg;
  157.     arg = xlgetarg();
  158.     xllastarg();
  159.     return (atom(arg) ? true : NIL);
  160. }
  161.  
  162. /* xsymbolp - is this an symbol? */
  163. LVAL xsymbolp()
  164. {
  165.     LVAL arg;
  166.     arg = xlgetarg();
  167.     xllastarg();
  168.     return (arg == NIL || symbolp(arg) ? true : NIL);
  169. }
  170.  
  171. /* xnumberp - is this a number? */
  172. LVAL xnumberp()
  173. {
  174.     LVAL arg;
  175.     arg = xlgetarg();
  176.     xllastarg();
  177.     return (fixp(arg) || floatp(arg) ? true : NIL);
  178. }
  179.  
  180. /* xintegerp - is this an integer? */
  181. LVAL xintegerp()
  182. {
  183.     LVAL arg;
  184.     arg = xlgetarg();
  185.     xllastarg();
  186.     return (fixp(arg) ? true : NIL);
  187. }
  188.  
  189. /* xfloatp - is this a float? */
  190. LVAL xfloatp()
  191. {
  192.     LVAL arg;
  193.     arg = xlgetarg();
  194.     xllastarg();
  195.     return (floatp(arg) ? true : NIL);
  196. }
  197.  
  198. /* xcharp - is this a character? */
  199. LVAL xcharp()
  200. {
  201.     LVAL arg;
  202.     arg = xlgetarg();
  203.     xllastarg();
  204.     return (charp(arg) ? true : NIL);
  205. }
  206.  
  207. /* xstringp - is this a string? */
  208. LVAL xstringp()
  209. {
  210.     LVAL arg;
  211.     arg = xlgetarg();
  212.     xllastarg();
  213.     return (stringp(arg) ? true : NIL);
  214. }
  215.  
  216. /* xarrayp - is this an array? */
  217. LVAL xarrayp()
  218. {
  219.     LVAL arg;
  220.     arg = xlgetarg();
  221.     xllastarg();
  222.     return (vectorp(arg) ? true : NIL);
  223. }
  224.  
  225. /* xstreamp - is this a stream? */
  226. LVAL xstreamp()
  227. {
  228.     LVAL arg;
  229.     arg = xlgetarg();
  230.     xllastarg();
  231.     return (streamp(arg) || ustreamp(arg) ? true : NIL);
  232. }
  233.  
  234. /* xobjectp - is this an object? */
  235. LVAL xobjectp()
  236. {
  237.     LVAL arg;
  238.     arg = xlgetarg();
  239.     xllastarg();
  240.     return (objectp(arg) ? true : NIL);
  241. }
  242.  
  243. /* xboundp - is this a value bound to this symbol? */
  244. LVAL xboundp()
  245. {
  246.     LVAL sym;
  247.     sym = xlgasymbol();
  248.     xllastarg();
  249.     return (boundp(sym) ? true : NIL);
  250. }
  251.  
  252. /* xfboundp - is this a functional value bound to this symbol? */
  253. LVAL xfboundp()
  254. {
  255.     LVAL sym;
  256.     sym = xlgasymbol();
  257.     xllastarg();
  258.     return (fboundp(sym) ? true : NIL);
  259. }
  260.  
  261. /* xnull - is this null? */
  262. LVAL xnull()
  263. {
  264.     LVAL arg;
  265.     arg = xlgetarg();
  266.     xllastarg();
  267.     return (null(arg) ? true : NIL);
  268. }
  269.  
  270. /* xlistp - is this a list? */
  271. LVAL xlistp()
  272. {
  273.     LVAL arg;
  274.     arg = xlgetarg();
  275.     xllastarg();
  276.     return (listp(arg) ? true : NIL);
  277. }
  278.  
  279. /* xendp - is this the end of a list? */
  280. LVAL xendp()
  281. {
  282.     LVAL arg;
  283.     arg = xlgalist();
  284.     xllastarg();
  285.     return (null(arg) ? true : NIL);
  286. }
  287.  
  288. /* xconsp - is this a cons? */
  289. LVAL xconsp()
  290. {
  291.     LVAL arg;
  292.     arg = xlgetarg();
  293.     xllastarg();
  294.     return (consp(arg) ? true : NIL);
  295. }
  296.  
  297. /* xeq - are these equal? */
  298. LVAL xeq()
  299. {
  300.     LVAL arg1,arg2;
  301.  
  302.     /* get the two arguments */
  303.     arg1 = xlgetarg();
  304.     arg2 = xlgetarg();
  305.     xllastarg();
  306.  
  307.     /* compare the arguments */
  308.     return (arg1 == arg2 ? true : NIL);
  309. }
  310.  
  311. /* xeql - are these equal? */
  312. LVAL xeql()
  313. {
  314.     LVAL arg1,arg2;
  315.  
  316.     /* get the two arguments */
  317.     arg1 = xlgetarg();
  318.     arg2 = xlgetarg();
  319.     xllastarg();
  320.  
  321.     /* compare the arguments */
  322.     return (eql(arg1,arg2) ? true : NIL);
  323. }
  324.  
  325. /* xequal - are these equal? (recursive) */
  326. LVAL xequal()
  327. {
  328.     LVAL arg1,arg2;
  329.  
  330.     /* get the two arguments */
  331.     arg1 = xlgetarg();
  332.     arg2 = xlgetarg();
  333.     xllastarg();
  334.  
  335.     /* compare the arguments */
  336.     return (equal(arg1,arg2) ? true : NIL);
  337. }
  338.  
  339. /* xset - built-in function set */
  340. LVAL xset()
  341. {
  342.     LVAL sym,val;
  343.  
  344.     /* get the symbol and new value */
  345.     sym = xlgasymbol();
  346.     val = xlgetarg();
  347.     xllastarg();
  348.  
  349.     /* assign the symbol the value of argument 2 and the return value */
  350.     setvalue(sym,val);
  351.  
  352.     /* return the result value */
  353.     return (val);
  354. }
  355.  
  356. /* xgensym - generate a symbol */
  357. LVAL xgensym()
  358. {
  359.     char sym[STRMAX+11]; /* enough space for prefix and number */
  360.     LVAL x;
  361.  
  362.     /* get the prefix or number */
  363.     if (moreargs()) {
  364.     x = xlgetarg();
  365.     switch (null(x) ? CONS : ntype(x)) {
  366.     case SYMBOL:
  367.         x = getpname(x);
  368.     case STRING:
  369.         strncpy(gsprefix,getstring(x),STRMAX);
  370.         gsprefix[STRMAX] = '\0';
  371.         break;
  372.     case FIXNUM:
  373.         gsnumber = getfixnum(x);
  374.         break;
  375.     default:
  376.         xlerror("bad argument type",x);
  377.     }
  378.     }
  379.     xllastarg();
  380.  
  381.     /* create the pname of the new symbol */
  382.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  383.  
  384.     /* make a symbol with this print name */
  385.     return (xlmakesym(sym));
  386. }
  387.  
  388. /* xmakesymbol - make a new uninterned symbol */
  389. LVAL xmakesymbol()
  390. {
  391.     return (makesymbol(FALSE));
  392. }
  393.  
  394. /* xintern - make a new interned symbol */
  395. LVAL xintern()
  396. {
  397.     return (makesymbol(TRUE));
  398. }
  399.  
  400. /* makesymbol - make a new symbol */
  401. LOCAL LVAL makesymbol(iflag)
  402.   int iflag;
  403. {
  404.     LVAL pname;
  405.  
  406.     /* get the print name of the symbol to intern */
  407.     pname = xlgastring();
  408.     xllastarg();
  409.  
  410.     /* make the symbol */
  411.     return (iflag ? xlenter(getstring(pname))
  412.               : xlmakesym(getstring(pname)));
  413. }
  414.  
  415. /* xsymname - get the print name of a symbol */
  416. LVAL xsymname()
  417. {
  418.     LVAL sym;
  419.  
  420.     /* get the symbol */
  421.     sym = xlgasymbol();
  422.     xllastarg();
  423.  
  424.     /* return the print name */
  425.     return (getpname(sym));
  426. }
  427.  
  428. /* xsymvalue - get the value of a symbol */
  429. LVAL xsymvalue()
  430. {
  431.     LVAL sym,val;
  432.  
  433.     /* get the symbol */
  434.     sym = xlgasymbol();
  435.     xllastarg();
  436.  
  437.     /* get the global value */
  438.     while ((val = getvalue(sym)) == s_unbound)
  439.     xlunbound(sym);
  440.  
  441.     /* return its value */
  442.     return (val);
  443. }
  444.  
  445. /* xsymfunction - get the functional value of a symbol */
  446. LVAL xsymfunction()
  447. {
  448.     LVAL sym,val;
  449.  
  450.     /* get the symbol */
  451.     sym = xlgasymbol();
  452.     xllastarg();
  453.  
  454.     /* get the global value */
  455.     while ((val = getfunction(sym)) == s_unbound)
  456.     xlfunbound(sym);
  457.  
  458.     /* return its value */
  459.     return (val);
  460. }
  461.  
  462. /* xsymplist - get the property list of a symbol */
  463. LVAL xsymplist()
  464. {
  465.     LVAL sym;
  466.  
  467.     /* get the symbol */
  468.     sym = xlgasymbol();
  469.     xllastarg();
  470.  
  471.     /* return the property list */
  472.     return (getplist(sym));
  473. }
  474.  
  475. /* xget - get the value of a property */
  476. LVAL xget()
  477. {
  478.     LVAL sym,prp;
  479.  
  480.     /* get the symbol and property */
  481.     sym = xlgasymbol();
  482.     prp = xlgasymbol();
  483.     xllastarg();
  484.  
  485.     /* retrieve the property value */
  486.     return (xlgetprop(sym,prp));
  487. }
  488.  
  489. /* xputprop - set the value of a property */
  490. LVAL xputprop()
  491. {
  492.     LVAL sym,val,prp;
  493.  
  494.     /* get the symbol and property */
  495.     sym = xlgasymbol();
  496.     val = xlgetarg();
  497.     prp = xlgasymbol();
  498.     xllastarg();
  499.  
  500.     /* set the property value */
  501.     xlputprop(sym,val,prp);
  502.  
  503.     /* return the value */
  504.     return (val);
  505. }
  506.  
  507. /* xremprop - remove a property value from a property list */
  508. LVAL xremprop()
  509. {
  510.     LVAL sym,prp;
  511.  
  512.     /* get the symbol and property */
  513.     sym = xlgasymbol();
  514.     prp = xlgasymbol();
  515.     xllastarg();
  516.  
  517.     /* remove the property */
  518.     xlremprop(sym,prp);
  519.  
  520.     /* return nil */
  521.     return (NIL);
  522. }
  523.  
  524. /* xhash - compute the hash value of a string or symbol */
  525. LVAL xhash()
  526. {
  527.     unsigned char *str;
  528.     LVAL len,val;
  529.     int n;
  530.  
  531.     /* get the string and the table length */
  532.     val = xlgetarg();
  533.     len = xlgafixnum(); n = (int)getfixnum(len);
  534.     xllastarg();
  535.  
  536.     /* get the string */
  537.     if (symbolp(val))
  538.     str = getstring(getpname(val));
  539.     else if (stringp(val))
  540.     str = getstring(val);
  541.     else
  542.     xlerror("bad argument type",val);
  543.  
  544.     /* return the hash index */
  545.     return (cvfixnum((FIXTYPE)hash(str,n)));
  546. }
  547.  
  548. /* xaref - array reference function */
  549. LVAL xaref()
  550. {
  551.     LVAL array,index;
  552.     int i;
  553.  
  554.     /* get the array and the index */
  555.     array = xlgavector();
  556.     index = xlgafixnum(); i = (int)getfixnum(index);
  557.     xllastarg();
  558.  
  559.     /* range check the index */
  560.     if (i < 0 || i >= getsize(array))
  561.     xlerror("array index out of bounds",index);
  562.  
  563.     /* return the array element */
  564.     return (getelement(array,i));
  565. }
  566.  
  567. /* xmkarray - make a new array */
  568. LVAL xmkarray()
  569. {
  570.     LVAL size;
  571.     int n;
  572.  
  573.     /* get the size of the array */
  574.     size = xlgafixnum() ; n = (int)getfixnum(size);
  575.     xllastarg();
  576.  
  577.     /* create the array */
  578.     return (newvector(n));
  579. }
  580.  
  581. /* xvector - make a vector */
  582. LVAL xvector()
  583. {
  584.     LVAL val;
  585.     int i;
  586.  
  587.     /* make the vector */
  588.     val = newvector(xlargc);
  589.  
  590.     /* store each argument */
  591.     for (i = 0; moreargs(); ++i)
  592.     setelement(val,i,nextarg());
  593.     xllastarg();
  594.  
  595.     /* return the vector */
  596.     return (val);
  597. }
  598.  
  599. /******************************************************************************
  600.  * (copy-array <src> <dest> [<pos>]) --> returns <dest>
  601.  * This function copies from array <src> into the preallocated array <dest>
  602.  * (allocate with 'make-array'). If the optional arg <pos> is given, then
  603.  * elements from <src> will be written into <dest> at index <pos>, otherwise
  604.  * <pos> defaults to 0. 
  605.  *
  606.  * This function was added to xlisp by Niels Mayer.
  607.  ******************************************************************************/
  608. LVAL Prim_COPY_ARRAY()
  609. {
  610.   register int size;
  611.   register LVAL *src, *dest;
  612.   LVAL src_array, dest_array, lval_pos;
  613.  
  614.   src_array = xlgavector();    /* get <src> */
  615.   dest_array = xlgavector();    /* get <dest> */
  616.   if moreargs()
  617.     lval_pos = xlgafixnum();    /* get optional <pos> */
  618.   else
  619.     lval_pos = NIL;
  620.   xllastarg();
  621.  
  622.   src = src_array->n_vdata;
  623.   dest = dest_array->n_vdata;
  624.  
  625.   if (getsize(src_array) < getsize(dest_array))    /* which is shortest? */
  626.     size = getsize(src_array);
  627.   else
  628.     size = getsize(dest_array);
  629.  
  630.   if (lval_pos) {
  631.     int pos = getfixnum(lval_pos);
  632.     int len = getsize(dest_array) - pos;
  633.     if ((len <= 0) || (pos < 0))
  634.       xlerror("Array position out of bounds.", lval_pos);    
  635.     if (len < size)
  636.       size = len;
  637.     dest = dest + pos;
  638.   }
  639.  
  640.   while (size--)
  641.     *dest++ = *src++;
  642.  
  643.   return (dest_array);
  644. }
  645.  
  646. /******************************************************************************
  647.  * (array-insert-pos <array> <pos> <elt>) --> returns the new <array>
  648.  * inserts <elt> at index <pos> in <array>. if <pos> < 0, then <elt> is
  649.  * appended to the end of <array>.
  650.  *
  651.  * This function was added to xlisp by Niels Mayer.
  652.  ******************************************************************************/
  653. LVAL Prim_ARRAY_INSERT_POS()
  654. {
  655.   register int i;
  656.   register LVAL *src, *dest;
  657.   LVAL src_array, dest_array, elt, lval_position;
  658.   int src_size, position;
  659.  
  660.   src_array = xlgavector();    /* get <array> */
  661.   lval_position = xlgafixnum();    /* get <pos>, a fixnum */
  662.   elt = nextarg();        /* get <elt>, which can be any lisp type */
  663.   xllastarg();
  664.  
  665.   src_size = getsize(src_array);
  666.   position = getfixnum(lval_position);
  667.   if (position >= src_size)
  668.     xlerror("Array insertion position out of bounds.", lval_position);
  669.   dest_array = newvector(src_size + 1);
  670.  
  671.   src = src_array->n_vdata;
  672.   dest = dest_array->n_vdata;
  673.  
  674.   if (position < 0) {        /* append <elt> to end of array */
  675.     i = src_size;
  676.     while (i--)
  677.       *dest++ = *src++;
  678.     *dest = elt;
  679.   }
  680.   else {            /* insert <elt> at <position> */
  681.     i = position;
  682.     while (i--)
  683.       *dest++ = *src++;
  684.     *dest++ = elt;
  685.     i = src_size - position;
  686.     while (i--)
  687.       *dest++ = *src++;
  688.   }
  689.   return (dest_array);
  690. }
  691.  
  692. /******************************************************************************
  693.  * (array-delete-pos <array> <pos>) --> returns the new <array>
  694.  * deletes the element at index <pos> in <array>. If <pos>==-1, then it
  695.  * will delete the last element in the array. 
  696.  * Note that this function is destructive. It reuses the old <array>'s
  697.  * elements.
  698.  *
  699.  * This function was added to xlisp by Niels Mayer.
  700.  ******************************************************************************/
  701. LVAL Prim_ARRAY_DELETE_POS()
  702. {
  703.   register int i;
  704.   register LVAL *src, *dest;
  705.   LVAL src_array, dest_array, lval_position;
  706.   int src_size, position;
  707.  
  708.   src_array = xlgavector();    /* get <array> */
  709.   lval_position = xlgafixnum();    /* get <pos>, a fixnum */
  710.   xllastarg();
  711.  
  712.   src_size = getsize(src_array);
  713.   position = getfixnum(lval_position);
  714.   if (position >= src_size)
  715.     xlerror("Array insertion position out of bounds.", lval_position);
  716.   if ((src_size - 1) > 0)
  717.     dest_array = newvector(src_size - 1);
  718.   else
  719.     return (NIL);
  720.  
  721.   src = src_array->n_vdata;
  722.   dest = dest_array->n_vdata;
  723.  
  724.   if (position < 0) {        /* remove last element of array */
  725.     i = src_size - 1;
  726.     while (i--)
  727.       *dest++ = *src++;
  728.   }
  729.   else {            /* remove <elt> at <position> */
  730.     i = position;
  731.     while (i--)
  732.       *dest++ = *src++;
  733.     src++;            /* don't copy the deleted elt */
  734.     i = src_size - (position + 1);
  735.     while (i--)
  736.       *dest++ = *src++;
  737.   }
  738.   return (dest_array);
  739. }
  740.  
  741. /* xerror - special form 'error' */
  742. LVAL xerror()
  743. {
  744.     LVAL emsg,arg;
  745.  
  746.     /* get the error message and the argument */
  747.     emsg = xlgastring();
  748.     arg = (moreargs() ? xlgetarg() : s_unbound);
  749.     xllastarg();
  750.  
  751.     /* signal the error */
  752.     xlerror(getstring(emsg),arg);
  753. }
  754.  
  755. /* xcerror - special form 'cerror' */
  756. LVAL xcerror()
  757. {
  758.     LVAL cmsg,emsg,arg;
  759.  
  760.     /* get the correction message, the error message, and the argument */
  761.     cmsg = xlgastring();
  762.     emsg = xlgastring();
  763.     arg = (moreargs() ? xlgetarg() : s_unbound);
  764.     xllastarg();
  765.  
  766.     /* signal the error */
  767.     xlcerror(getstring(cmsg),getstring(emsg),arg);
  768.  
  769.     /* return nil */
  770.     return (NIL);
  771. }
  772.  
  773. /* xbreak - special form 'break' */
  774. LVAL xbreak()
  775. {
  776.     LVAL emsg,arg;
  777.  
  778.     /* get the error message */
  779.     emsg = (moreargs() ? xlgastring() : NIL);
  780.     arg = (moreargs() ? xlgetarg() : s_unbound);
  781.     xllastarg();
  782.  
  783.     /* enter the break loop */
  784.     xlbreak((emsg ? getstring(emsg) : (unsigned char *)"**BREAK**"),arg);
  785.  
  786.     /* return nil */
  787.     return (NIL);
  788. }
  789.  
  790. /* xcleanup - special form 'clean-up' */
  791. LVAL xcleanup()
  792. {
  793.     xllastarg();
  794.     xlcleanup();
  795. }
  796.  
  797. /* xtoplevel - special form 'top-level' */
  798. LVAL xtoplevel()
  799. {
  800.     xllastarg();
  801.     xltoplevel();
  802. }
  803.  
  804. /* xcontinue - special form 'continue' */
  805. LVAL xcontinue()
  806. {
  807.     xllastarg();
  808.     xlcontinue();
  809. }
  810.  
  811. /* xevalhook - eval hook function */
  812. LVAL xevalhook()
  813. {
  814.     LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
  815.  
  816.     /* protect some pointers */
  817.     xlstkcheck(3);
  818.     xlsave(oldenv);
  819.     xlsave(oldfenv);
  820.     xlsave(newenv);
  821.  
  822.     /* get the expression, the new hook functions and the environment */
  823.     expr = xlgetarg();
  824.     newehook = xlgetarg();
  825.     newahook = xlgetarg();
  826.     newenv = (moreargs() ? xlgalist() : NIL);
  827.     xllastarg();
  828.  
  829.     /* bind *evalhook* and *applyhook* to the hook functions */
  830.     olddenv = xldenv;
  831.     xldbind(s_evalhook,newehook);
  832.     xldbind(s_applyhook,newahook);
  833.  
  834.     /* establish the environment for the hook function */
  835.     if (newenv) {
  836.     oldenv = xlenv;
  837.     oldfenv = xlfenv;
  838.     xlenv = car(newenv);
  839.     xlfenv = cdr(newenv);
  840.     }
  841.  
  842.     /* evaluate the expression (bypassing *evalhook*) */
  843.     val = xlxeval(expr);
  844.  
  845.     /* restore the old environment */
  846.     xlunbind(olddenv);
  847.     if (newenv) {
  848.     xlenv = oldenv;
  849.     xlfenv = oldfenv;
  850.     }
  851.  
  852.     /* restore the stack */
  853.     xlpopn(3);
  854.  
  855.     /* return the result */
  856.     return (val);
  857. }
  858.  
  859.